perm filename INTERP.PAL[HAL,HE]8 blob
sn#155559 filedate 1975-04-23 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00012 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 .SBTTL Interpreter
C00007 00003 Interpreter itself: INTERP
C00012 00004 GETARG, GETSCA, GETVEC, GETTRN, GETVAL
C00016 00005 Variable declaration: VARIABLE
C00017 00006 Stack ops: GTVAL, CHNGE, PUSH, POP, COPY, REPLACE, FLUSH
C00020 00007 Flow-of-control: PROC, RETURN
C00026 00008 FORCHK, SPROUT, JUMP, JUMPZ, TERMINATE
C00034 00009 return scalars: SADD, SSUB, SMUL, SDIV, SNEG, VDOT, PVDOT, VMAG
C00040 00010 Vector utilities: UNITV, CROSV
C00046 00011 Return vectors: SVMUL, TVMUL, VMAKE, VADD
C00050 00012 Return a trans: TMAKE, TTMUL
C00054 ENDMK
C⊗;
.SBTTL Interpreter
;Register uses in the interpreter:
; R3 interpreter stack pointer
; R4 points to interpreter status block
;Each interpreter has a stack which it uses to store pointers to
;currently "open" variables. During the course of a calculation,
;operands and temporary result cells will be open in this fashion.
;The "interpreter stack" is pointed to by R3. When a new interpreter
;is sprouted, it is given a new stack area. Each interpreter has
;certain status information which facilitates transfer of control
;between interpreters. This information is kept in the interpreter
;status block, which is always pointed to by R4. Most important are
;the IPC, the Interpreter Program Counter, the ENV, which points to
;the local environment, and LEV, which stores the current lexical
;level.
;Each procedure has an environment, which is a data area holding
;information vital to that procedure. This includes pointers to all
;the variables local to that procedure, and return information.
INSTSZ == 20 ;Size of an interpreter stack
;Interpreter status block
II == 0
XX IPC ;Interpreter program counter
XX STKBAS ;Location of start of stack area. Needed
;for eventual reclamation.
XX ICR ;Interpreter cross-reference (to HAL code)
XX ENV ;Location of local environment
XX LEV ;Lexical level of current execution
XX STA ;Status bits for condition codes: 0 means all well.
XX PCB ;Location of process control block (for reclamation)
XX EVT ;The event to signal as this interpreter goes away
ISBS == II/2 ;Size (in words) of interpreter status block
;Fixed fields in the environment of each process
II == 0
XX SLINK ;Pointer to environment of next (outer, lower
; numbered) block
XX OLEV ;Old level. The lexical level of calling process.
XX OENV ;Old environment, the one for the calling process.
XX OIPC ;Old IPC. Program counter for calling process.
XX LVARS ;First location where pointers to local variables go
;Interpreter itself: INTERP
INTERP:
OUTSTR HELLO ;
INT1: MOV @IPC(R4),R0 ;R0 ← next instruction
BLT INTER1 ;Instruction out of range
CMP R0,#INSEND ;Is instruction too large?
BHI INTER1 ;Yes.
ADD #2,IPC(R4) ;Bump IPC
JSR PC,@INTOPS(R0) ;Call the appropriate routine
BR INTCPL(R0) ;R0 should have an completion code. Branch accordingly.
INTCPL: BR INTSTS ;No error. Gather statistics.
HALERR INTMS2 ;Error.
INTSTS: BR INT1 ;No statistics code written yet.
INTER1: HALERR INTMS1
INTMS1: ASCIE /INTERPRETER INSTRUCTION OUT OF RANGE/
INTMS2: ASCIE /INTERPRETED INSTRUCTION RETURNED FAILURE/
HELLO: ASCIE </
HELLO THERE. I AM A NEWBORN INTERPRETER.
/>
.MACRO MAKEOP CNAME, ANAME ;Compiler name, Address name
XX CNAME
ANAME
.ENDM
INTOPS:
.INSRT INTOPS.PAL[HAL,HE]
;The interpreter operation table
INSEND = II ;Marks the end of the instructions
; GETARG, GETSCA, GETVEC, GETTRN, GETVAL
GETARG:
;Arguments:
; R0=variable name: low byte is lexical level, high byte is offset.
; R4=pointer to interpreter status block.
;Result:
; R0← pointer to address of desired variable.
; R1 clobbered.
;This routine returns in R0 a pointer to the location in the current
; environment (or, if necessary, more global environment) which
; points to the variable which is named in R0.
MOV R2,-(SP) ;Save R2
MOVB R0,R1 ;R1 ← Lexical level desired
CLRB R0 ;
SWAB R0 ;R0 ← Offset
MOV ENV(R4),R2 ;R2 ← LOC[local environment]
SUB LEV(R4),R1 ;R1 ← Difference in levels: desired-got
BEQ GTRG1 ;Diff=0; can use R2 as pointer at right base.
BHI GTERR ;If diff>0, then value inaccessible.
GTRG2: MOV SLINK(R2),R2;Must go up a level. R2 ← LOC[more global environment]
INC R1 ;R1 ← New difference in levels
BNE GTRG2 ;If not yet good, then move up another level
GTRG1: ADD R2,R0 ;R0 ← environment + offset = location of desired pointer
MOV (SP)+,R2 ;Restore R2.
RTS PC ;Done.
GTERR: HALERR GTMS1
GTMS1: ASCIE /ATTEMPT TO ACCESS UNAVAILABLE VARIABLE/
GETSCA: ;Gets place for a scalar result, and places a pointer on
;the interpreter stack. Location is returned in R0.
;Simple procedure.
MOV #2,R0 ;Number of words needed
JSR PC,GTFREE ;R0 ← LOC[new block]
; MOV #RES,R0 ;Temporary kludge. Delete this line in final runs.
MOV R0,-(R3) ;Push new value cell pointer on interpreter stack.
RTS PC ;Done
GETVEC: ;Gets place for a vector result, and places a pointer on
;the interpreter stack. Location is returned in R0.
;Simple procedure.
MOV #10,R0 ;Number of words needed
JSR PC,GTFREE ;R0 ← LOC[new block]
; MOV #RES,R0 ;Temporary kludge. Delete this line in final runs.
MOV R0,-(R3) ;Push new value cell pointer on interpreter stack.
RTS PC ;Done
GETTRN: ;Gets place for a trans result, and places a pointer on
;the interpreter stack. Location is returned in R0.
;Simple procedure.
MOV #40,R0 ;Number of words needed
JSR PC,GTFREE ;R0 ← LOC[new block]
; MOV #RES,R0 ;Temporary kludge. Delete this line in final runs.
MOV R0,-(R3) ;Push new value cell pointer on interpreter stack.
RTS PC ;Done
GETVAL:
;Should access graph structure pointed to by R0, return pointer to
;valid value cell in R0. But for the time being, just returns. This
;works when not using graph structure.
RTS RF ;Done
;Variable declaration: VARIABLE
VARIABLE:
;Two args: the offset and the address. Puts a pointer in the current
;environment to that variable, giving it that offset.
MOV ENV(R4),R0 ;R0 ← LOC[environment]
ADD @IPC(R4),R0 ;R0 ← LOC[pointer to variable]
ADD #2,IPC(R4) ;Bump IPC
MOV @IPC(R4),(R0);Put the pointer in its place.
ADD #2,IPC(R4) ;Bump IPC
CLR R0 ;Clear condition code.
RTS PC ;Done
;Stack ops: GTVAL, CHNGE, PUSH, POP, COPY, REPLACE, FLUSH
GTVAL: MOV @IPC(R4),R0 ;Pick up level-offset name of argument
ADD #2,IPC(R4) ;Bump IPC
JSR PC,GETARG ;R0 ← LOC[LOC[desired graph node]]
MOV (R0),R0 ;R0 ← LOC[desired graph node]
CALL GETVAL,<R0>;R0 ← value
MOV R0,-(R3) ;Push value on interpreter stack.
CLR R0 ;Clear condition code.
RTS PC ;Done
CHNGE: MOV @IPC(R4),R0 ;Pick up level-offset name of argument
ADD #2,IPC(R4) ;Bump IPC
JSR PC,GETARG ;R0 ← LOC[LOC[Desired graph node]]
MOV (R0),R0 ;R0 ← LOC[Desired graph node]
CALL CHANGE,<R0,(R3)>
POP: TST (R3)+ ;Pop stack
CLR R0 ;Clear condition code.
RTS PC ;Done
PUSH: MOV @IPC(R4),-(R3);Put argument directly on stack
ADD #2,IPC(R4) ;Bump IPC
CLR R0 ;Clear condition code.
RTS PC ;Done
COPY: MOV @IPC(R4),R0 ;Pick up argument.
ADD #2,IPC(R4) ;Bump IPC
ADD R0,R0 ;Double R0 to make it in bytes
ADD R3,R0 ;R0 ← LOC[stack element to be copied to top]
MOV (R0),-(R3) ;Copy it onto top of stack.
CLR R0 ;Clear condition code.
RTS PC ;Done
REPLAC: MOV @IPC(R4),R0 ;Pick up argument.
ADD #2,IPC(R4) ;Bump IPC
ADD R0,R0 ;Double R0 to make it in bytes
ADD R3,R0 ;R0 ← LOC[stack element to be copied into]
MOV -(R3),(R0) ;Copy top of stack into it.
CLR R0 ;Clear condition code.
RTS PC ;Done
FLUSH: MOV STKBAS(R4),R3;Reset the stack base.
CLR R0 ;Clear condition code.
RTS PC ;Done
;Flow-of-control: PROC, RETURN
PROC:
;Procedure call. Arguments:
; Destination.
; List of variables which are to be inserted in appropriate
; locations in the local storage of procedure. These are
; in the format variable (ie level-offset pair), new offset
; (right justified in the second word).
; There is a zero word to finish these.
;At the destination address can be found:
II == 0
XX FSLGTH ;Number of words to get from free storage
;for local variable pointers
XX PLEV ;Lexical level of procedure
DSLGTH == II ;Number of words before code starts
;Value parameters should have first been copied first into local temps
; (which have been arranged by the compiler), and then the temps are
; passed by reference. Eventual problem: to know which variables to
; really kill as the procedure is exited.
MOV R2,-(SP) ;Save R2
MOV @IPC(R4),R2 ;R2 ← LOC[destination]
ADD #2,IPC(R4) ;Bump IPC
MOV FSLGTH(R2),R0 ;R0 ← Number of words to get.
JSR PC,GTFREE ;R0 ← LOC[block with that number of words]
;initialize pointer to lexical level:
MOV PLEV(R2),R1 ;R1 ← Lexical level of procedure
MOV ENV(R4),R2 ;R2 ← LOC[current environment]
SUB LEV(R4),R1 ;R1 ← Difference in levels: desired-got
BEQ PRC1 ;Diff=0; can use R2 as pointer at right environment.
PRC2: MOV SLINK(R2),R2;No, must go up a level. R2 ← LOC[base of upper area]
INC R1 ;R1 ← New difference in levels
BNE PRC2 ;If not yet good, then move up another level
PRC1: MOV R2,SLINK(R0);SLINK[new environment] ← correct global environment
;Put copies of local variables in new area
MOV R0,-(SP) ;Stack LOC[new environment]
MOV @IPC(R4),R0 ;R0 ← level-offset pair for an argument
BEQ PRC3 ;If there are no more, go to next phase
PRC4: ADD #2,IPC(R4) ;Else bump IPC
JSR PC,GETARG ;R0 ← LOC[LOC[graph node]]
MOV @IPC(R4),R1 ;R1 ← offset in new block
ADD #2,IPC(R4) ;Bump IPC
ADD (SP),R1 ;R1 ← LOC[place in new environment to put pointer]
MOV (R0),(R1) ;new environment gets pointer to LOC[argument graph node]
MOV @IPC(R4),R0 ;R0 ← level-offset pair for an argument
BNE PRC4 ;If there are more, go back and treat them
PRC3: ADD #2,IPC(R4) ;Bump IPC one last time
;Save the old context in the new area
MOV (SP)+,R1 ;R1 ← LOC[new environment]
MOV LEV(R4),OLEV(R1) ;Store the old level
MOV ENV(R4),OENV(R1) ;Store the old environment location
MOV IPC(R4),OIPC(R1) ;Store the return address
;Set up the new context for procedure
MOV PLEV(R2),LEV(R4) ;New lexical level
MOV R1,ENV(R4) ;New environment location
ADD #DSLGTH,R2 ;R2 ← Place where execution should begin
MOV R2,IPC(R4) ;New program counter
MOV (SP)+,R2 ;Restore R2
CLR R0 ;Clear condition code.
RTS PC ;Done
RETURN:
;Returns from a procedure call to calling program. Since variables are
;passed by reference, it is not necessary to do any copying of values.
;All that is needed is to restore the context of the caller and to
;discard the display.
MOV ENV(R4),R0 ;R0 ← LOC[current environment]
MOV OLEV(R0),LEV(R4) ;Restore the old lexical level
MOV OENV(R0),ENV(R4) ;Restore the old environment
MOV OIPC(R0),IPC(R4) ;Restore the IPC
JSR PC,RLFREE ;Release storage of old display
CLR R0 ;Clear condition code.
RTS PC ;Done
; FORCHK, SPROUT, JUMP, JUMPZ, TERMINATE
FORCHK:
;Assume that the stack has, from surface in, the increment, the
; final value, and the control variable's value, all of which are
; scalar values. If (FINAL-CONVAR)*(INCREMENT) ≥ 0 then this is a
; no-op; otherwise, jump to the destination.
;Arguments: destination.
LDF @2(R3),AC0 ;AC0 ← final value
SUBF @4(R3),AC0 ;AC0 ← final - current
MULF @(R3),AC0 ;AC0 ← (final - current)*increment
MOV @IPC(R4),R0 ;R0 ← destination
ADD #2,IPC(R4) ;Bump IPC
CFCC ;
BGE FOR1 ;Shall this be a no-op?
MOV R0,IPC(R4) ;No; set new IPC.
FOR1: CLR R0 ;
RTS PC ;Done
SPROUT:
COMMENT ⊗
Arguments: One address in pseudo-code for each of the several forks
starting up, followed by a 0 word. This is to be used only for
cobegins, not for servos. Each new interpreter is given an
interpreter status block and is then scheduled. As each terminates,
it signals its defining event. Since each of these has the same
event, the current interpreter need only wait until they all happen.
⊗
PDBSTA == 40 ;Process Descriptor Block Status Word
PDBR0 == 60 ;Where R0 is saved
PDBR1 == 62 ;Where R1 is saved
PDBR2 == 64 ;Where R2 is saved
PDBR3 == 66 ;Where R3 is saved
PDBR4 == 70 ;Where R4 is saved
PDBR5 == 72 ;Where R5 is saved
PDBSP == 74 ;Where SP is saved
PDBPC == 76 ;Where PC is saved
PDBSSV == 104 ;Process Descriptor Block Stack Save Length Word
MOV R2,-(SP) ;Save R2.
MOV R3,-(SP) ;Save R3. Caution: cannot use interpreter stack now.
CLR R3 ;R3 is the count of how many inferiors to spawn.
EVMAK ;-(SP) ← Event identifier for communication with infs.
SPR2: MOV @IPC(R4),R2 ;R2 ← next argument
BEQ SPR1 ;If zero, then we have spawned all the inferiors.
ADD #2,IPC(R4) ;Bump IPC
INC R3 ;Yes. Count it.
MOV #ISBS,R0 ;R0 ← Size (in words) of an interpreter status block
JSR PC,GTFREE ;R0 ← LOC[new interpreter status block]
MOV R2,IPC(R0) ;new IPC ← jump address
MOV ENV(R4),ENV(R0) ;new ENV ← old ENV
MOV LEV(R4),LEV(R0) ;new LEV ← old LEV
MOV (SP),EVT(R0);new EVT ← event just created.
MOV R0,-(SP) ;Save LOC[new interpreter status block]
MOV #INSTSZ,R0 ;R0 ← Size needed for an interpreter stack
JSR PC,GTFREE ;R0 ← LOC[new interpreter stack]
MOV (SP)+,R1 ;R1 ← LOC[new interpreter status block]
MOV R0,STKBAS(R1) ;Store away new stack base
ADD #2*INSTSZ,R0 ;R0 ← LOC[top of new stack] (INSTSZ is in bytes)
MOV R1,-(SP) ;Save R1
MOV R0,-(SP) ;Save R0
MOV #210,R0 ;Room for process descriptor
JSR PC,GTFREE ;R0 ← LOC[new process descriptor]
MOV #UFPUSE+UGPSAV,PDBSTA(R0);Use floating point, use saved registers.
MOV #100,PDBSSV(R0) ;Length of stack to be saved.
MOV R2,PDBR2(R0) ;Transfer register 2
MOV (SP)+,R1 ;R1 ← LOC[new interpreter stack top]
MOV R1,PDBR3(R0) ;Store away new interp stack pointer (reg 3)
MOV (SP)+,R1 ;R1 ← LOC[new ISB]
MOV R0,PCB(R1) ;Store away LOC[PCB] in new ISB
MOV R1,PDBR4(R0) ;Store away LOC[ISB] in reg 4 of PCB
MOV R5,PDBR5(R0) ;Store away reg 5
MOV SP,R1 ;
TST (R1)+ ;
MOV R1,PDBSP(R0) ;Store away the new stack pointer (reg 6)
MOV #INTERP,PDBPC(R0);Store away the new PC
ADD #PDBSTA,R0 ;R0 ← middle of Process Descriptor Block
SCHEDU R0,#INTERP,#0,#2;Cause the new process to be started, suspended
BR SPR2 ;Go handle the next inferior.
SPR1: ADD #2,IPC(R4) ;Bump IPC
SPR4: DEC R3 ;Another wait to be done?
BMI SPR3 ;No, we are finished.
EVWAIT (SP) ;Wait for an inferior to come back.
BCC SPR4 ;If all well, wait for the next one.
HALERR SPRMES ;The event was killed!
SPR3: EVKIL (SP)+ ;Kill the event now, remove from stack
MOV (SP)+,R3 ;Restore R3
MOV (SP)+,R2 ;Restore R2
CLR R0 ;Clear condition code.
RTS PC ;Done
SPRMES: ASCIE /BAD RETURN FROM INTERPRETER/
JUMP:
;Takes one argument: the new address.
MOV @IPC(R4),IPC(R4)
CLR R0 ;Clear condition code.
RTS PC ;Done
JUMPZ:
;Takes one argument: the new address. Jumps if top of stack is zero.
MOV (R3)+,R0 ;R0 ← LOC[arg]
LDF (R0),AC0 ;AC0 ← arg
CFCC ;
BNE JMPZ1 ;Zero?
MOV @IPC(R4),IPC(R4) ;Yes
JMPZ1: ADD #2,IPC(R4) ;Bump IPC
CLR R0 ;Clear condition code.
RTS PC ;Done
TERMINATE:
;End this interpreter. Currently does not attempt to reclaim storage.
EVSIG EVT(R4) ;Announce that we are about to disappear.
MOV STKBAS(R4),R0 ;Reclaim interpreter stack
JSR PC,RLFREE ;
MOV PCB(R4),R0 ;Reclaim process control block (may be dangerous)
JSR PC,RLFREE ;
MOV R4,R0 ;Reclaim Interpreter Status Block
JSR PC,RLFREE ;
DISMIS ;Go away
;return scalars: SADD, SSUB, SMUL, SDIV, SNEG, VDOT, PVDOT, VMAG
;All timings are averages of 1000 runs. They take into account
;the cost of the RTS but not the JSR. It is assumed that GETSCA
;and GETVEC take no time.
;30 microseconds
SADD: ;Scalar ← Scalar + Scalar
LDF @(R3)+,AC0 ;AC0 ← arg 2
ADDF @(R3)+,AC0 ;AC0 ← arg2 + arg1
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
CLR R0 ;Clear condition code.
RTS PC ;Done
SSUB: ;Scalar ← Scalar - Scalar
LDF @2(R3),AC0 ;AC0 ← arg 1
SUBF @(R3)+,AC0 ;AC0 ← arg1 - arg2
TST (R3)+ ;Move past first argument
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
CLR R0 ;Clear condition code.
RTS PC ;Done
;30 microseconds
SMUL: ;Scalar ← scalar * scalar
LDF @(R3)+,AC0 ;AC0 ← arg 2
MULF @(R3)+,AC0 ;AC0 ← arg2 * arg1
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
CLR R0 ;Clear condition code.
RTS PC ;Done
;33 microseconds
SDIV: ;Scalar ← Scalar / Scalar
LDF @(R3)+,AC1 ;AC1 ← arg 2
LDF @(R3)+,AC0 ;AC0 ← arg 1
DIVF AC1,AC0 ;AC0 ← arg1 / arg2
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
CLR R0 ;Clear condition code.
RTS PC ;Done
;26 microseconds
SNEG: ;Scalar ← -Scalar
LDF @(R3)+,AC0 ;AC0 ← arg
NEGF AC0 ;AC0 ← -arg
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
CLR R0 ;Clear condition code.
RTS PC ;Done
;96 -- 116 microseconds
VDOT: ;Scalar ← Vector dot Vector
;S ← (X1X2 + Y1Y2 + Z1Z2) / W1W2
MOV R2,-(SP) ;Save R2.
MOV (R3)+,R1 ;R1 ← LOC[arg 2]
MOV (R3)+,R0 ;R0 ← LOC[arg 1]
CLRF AC0 ;AC0 ← 0. Running total
MOV #3,R2 ;R2 ← 3: Length of vector
VDV1: LDF (R0)+,AC1 ;Form sum of products of first 3 terms
MULF (R1)+,AC1 ;
ADDF AC1,AC0 ;
SOB R2,VDV1 ;Loop until all 3 fields done.
DIVF (R0),AC0 ;Divide by W1
DIVF (R1),AC0 ;Divide by W2. AC0 now has answer.
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
MOV (SP)+,R2 ;Restore R2
CLR R0 ;Clear condition code.
RTS PC ;Done
;103 -- 116 microseconds
PVDOT: ;Scalar ← Plane dot Vector
;S ← X1X2 + Y1Y2 + Z1Z2 + W1W2
MOV R2,-(SP) ;Save R2.
MOV (R3)+,R1 ;R1 ← LOC[arg 2]
MOV (R3)+,R0 ;R0 ← LOC[arg 1]
CLRF AC0 ;AC0 ← 0. Running total
MOV #4,R2 ;R2 ← 4: Length of vector and weight
PDV1: LDF (R0)+,AC1 ;Form sum of products of all 4 terms
MULF (R1)+,AC1 ;
ADDF AC1,AC0 ;
SOB R2,PDV1 ;Loop until all 3 fields done.
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store result
MOV (SP)+,R2 ;Restore R2
CLR R0 ;Clear condition code.
RTS PC ;Done
;199 -- 207 microseconds
VMAG: ;Scalar ← Norm (vector)
;S ← SQRT(XX + YY+ ZZ) / W
MOV (R3)+,R1 ;R1 ← LOC[arg]
LDF (R1)+,AC0 ;AC0 ← X
MULF AC0,AC0 ;AC0 ← XX
LDF (R1)+,AC1 ;AC1 ← Y
MULF AC1,AC1 ;AC1 ← YY
ADDF AC1,AC0 ;AC0 ← XX + YY
LDF (R1)+,AC1 ;AC1 ← Z
MULF AC1,AC1 ;AC1 ← ZZ
ADDF AC1,AC0 ;AC0 ← XX + YY + ZZ
MOV R1,-(SP) ;Push LOC[W] onto system stack, to save across SQRTF
JSR PC,SQRTF ;AC0 ← SQRT(XX + YY + ZZ)
DIVF @(SP)+,AC0 ;AC0 ← AC0 / W
JSR PC,GETSCA ;R0 ← -(R3) ← LOC[new scalar block]
STF AC0,(R0) ;Store answer
CLR R0 ;Clear condition code.
RTS PC ;Done
;Vector utilities: UNITV, CROSV
;281 -- 286 microseconds *** maybe don't need this procedure
UNITV: ;Vector ← V / Norm(V)
;S ← SQRT(XX + YY+ ZZ) / W
MOV R2,-(SP) ;Save R2
MOV (R3),R1 ;R1 ← LOC[arg]
LDF (R1)+,AC0 ;AC0 ← X
MULF AC0,AC0 ;AC0 ← XX
LDF (R1)+,AC1 ;AC1 ← Y
MULF AC1,AC1 ;AC1 ← YY
ADDF AC1,AC0 ;AC0 ← XX + YY
LDF (R1)+,AC1 ;AC1 ← Z
MULF AC1,AC1 ;AC1 ← ZZ
ADDF AC1,AC0 ;AC0 ← XX + YY + ZZ
MOV R1,-(SP) ;Save R1 across SQRTF
JSR PC,SQRTF ;AC0 ← SQRT(XX + YY + ZZ)
MOV (SP)+,R1 ;Restore R1
DIVF (R1),AC0 ;AC0 ← Norm = SQRT / W
MOV (R3)+,R1 ;R1 ← LOC[arg]
JSR PC,GETVEC ;R0 ← -(R3) ← LOC[new vector block]
MOV #3,R2 ;R2 ← count of fields
UNITV1: LDF (R1)+,AC1 ;AC1 ← field of vector
DIVF AC0,AC1 ;divide by norm
STF AC1,(R0)+ ;Store result
SOB R2,UNITV1 ;Loop until done
MOV (R1)+,(R0)+ ;Copy W.
MOV (R1),(R0) ; (two words long)
MOV (SP)+,R2 ;Restore R2
CLR R0 ;Clear condition code
RTS PC ;Done
;172 -- 184 microseconds *** maybe don't need this procedure
CROSV: ;Vector ← Vector cross Vector
;X ← Y1Z2 - Y2Z1
;Y ← X2Z1 - X1Z2
;Z ← X1Y2 - X2Y1
;W ← W1W2
;AC0, 1, 2, 3, 4, 5 are garbaged by this routine.
MOV R2,-(SP) ;Save R2
MOV (R3),R2 ;R2 ← LOC[arg 2]
JSR PC,GETVEC ;R0 ← -(R3) ← LOC[new vector block]
MOV 4(R3),R1 ;R1 ← LOC[arg 1]. Must not pop R3 stack yet!
LDF 14(R1),AC0 ;AC0 ← W1
MULF 14(R2),AC0 ;AC0 ← W1W2
STF AC0,14(R0) ;Store AC0 → W
LDF 4(R1),AC0 ;AC0 ← Y1
LDF (R2),AC1 ;AC1 ← X2
LDF 4(R2),AC2 ;AC2 ← Y2
LDF (R1),AC3 ;AC3 ← X1
STF AC3,AC4 ;AC4 ← X1
STF AC0,AC5 ;AC5 ← Y1
MULF AC2,AC3 ;AC3 ← X1Y2
MULF AC1,AC0 ;AC0 ← X2Y1
SUBF AC0,AC3 ;AC3 ← X1Y2 - X2Y1
STF AC3,10(R0) ;Z ← AC3
LDF 10(R2),AC0 ;AC0 ← Z2
LDF 10(R1),AC3 ;AC3 ← Z1
MULF AC4,AC0 ;AC0 ← X1Z2
MULF AC3,AC1 ;AC1 ← X2Z1
SUBF AC0,AC1 ;AC1 ← X2Z1 - X1Z2
STF AC1,4(R0) ;Y ← AC1
LDF 10(R2),AC0 ;AC0 ← Z2
MULF AC5,AC0 ;AC0 ← Y1Z2
MULF AC2,AC3 ;AC3 ← Y2Z1
SUBF AC3,AC0 ;AC0 ← Y1Z2 - Y2Z1
STF AC0,(R0) ;X ← AC0
MOV (R3)+,2(R3) ;Put result cell where first argument was
TST (R3)+ ;Put stack pointer in right place
MOV (SP)+,R2 ;Restore R2
CLR R0 ;Clear condition code
RTS PC ;Done
;Return vectors: SVMUL, TVMUL, VMAKE, VADD
;83 -- 91 microseconds
SVMUL: ;Vector ← Scalar * Vector
;X ← S*X, Y ← S*Y, Z ← S*Z, W ← W
MOV R2,-(SP) ;Save R2
MOV (R3)+,R1 ;R1 ← LOC[vector]
LDF @(R3)+,AC0 ;AC0 ← scalar;
JSR PC,GETVEC ;R0 ← -(R3) ← LOC[new vector block]
MOV #3,R2 ;R2 ← 3: How many fields to handle
SVM1: LDF (R1)+,AC1 ;AC1 ← next field of vector
MULF AC0,AC1 ;AC1 ← product
STF AC1,(R0)+ ;Store result
SOB R2,SVM1 ;Loop until all 3 fields done.
MOV (R1)+,(R0)+ ;Transfer W
MOV (R1)+,(R0)+ ; which is 2 words long.
MOV (SP)+,R2 ;Restore R2
CLR R0 ;Clear condition code
RTS PC ;Done
VMAKE:
LDF @(R3)+,AC1 ;Fetch X
LDF @(R3)+,AC2 ;Fetch Y
LDF @(R3)+,AC3 ;Fetch Z
JSR PC,GETVEC ;R0 ← -(R3) ← LOC[new vector]
STF AC1,(R0)+ ;Store X
STF AC2,(R0)+ ;Store Y
STF AC3,(R0)+ ;Store Z
MOV ONE,(R0)+ ;Store W
CLR (R0) ;Store W (second word)
CLR R0 ;Clear condition code
RTS PC ;Done
VADD:
MOV (R3)+,R0 ;R0 ← LOC[arg 1]
MOV (R3)+,R1 ;R1 ← LOC[arg 1]
LDF (R0)+,AC1 ;Calculate X
ADDF (R1)+,AC1 ;
LDF (R0)+,AC2 ;Calculate Y
ADDF (R1)+,AC2 ;
LDF (R0)+,AC3 ;Calculate Z
ADDF (R1)+,AC3 ;
JSR PC,GETVEC ;R0 ← -(R3) ← LOC[new vector]
STF AC1,(R0)+ ;Store X
STF AC2,(R0)+ ;Store Y
STF AC3,(R0)+ ;Store Z
MOV ONE,(R0)+ ;Assume W is 1
CLR (R0) ;
CLR R0 ;Clear condition code
RTS PC ;Done
;283 -- 324 microseconds
TVMUL: ;Vector ← Trans * Vector
MOV R2,-(SP) ;Save R2
MOV (R3),R2 ;R2 ← LOC[vector]
MOV 2(R3),R0 ;R0 ← LOC[trans]
CLRF AC1 ;X ← 0
CLRF AC2 ;Y ← 0
CLRF AC3 ;Z ← 0
MOV #4,R1 ;R1 ← How many columns left to go
TVM1: LDF (R2)+,AC0 ;AC0 ← field of vector
STF AC0,AC5 ;AC5 ← copy of AC0
MULF (R0)+,AC0 ;
ADDF AC0,AC1 ;Add partial result to X
LDF AC5,AC0 ;Restore AC0
MULF (R0)+,AC0 ;
ADDF AC0,AC2 ;Add partial result to Y
LDF AC5,AC0 ;Restore AC0
MULF (R0)+,AC0 ;
ADDF AC0,AC3 ;Add partial result to Z.
ADD #4,R0 ;Skip bottom row
SOB R1,TVM1 ;Go back to do all 4 columns.
JSR PC,GETVEC ;R0 ← -(R3) ← LOC[new vector]
STF AC1,(R0)+ ;Store X
STF AC2,(R0)+ ;Store Y
STF AC3,(R0)+ ;Store Z
MOV -4(R2),(R0)+;Copy W from the vector
MOV -2(R2),(R0) ; (2 words long)
MOV (R3)+,2(R3) ;Put result cell where first argument was
TST (R3)+ ;Put stack pointer in right place
MOV (SP)+,R2 ;Restore R2
CLR R0 ;Clear condition code
RTS PC ;Done
ONE: 40200 ;First word of floating 1.000 (second word zero)
;Return a trans: TMAKE, TTMUL
TMAKE:
;All that is required is to take the rot part of the first argument,
;and the vector from the second part;
MOV R2,-(SP) ;Save R2
MOV (R3)+,R1 ;R1 ← LOC[arg 1]
MOV (R3)+,-(SP) ;Push LOC[arg 2]
JSR PC,GETTRN ;R0 ← -(R3) ← LOC[new trans]
MOV #14,R2 ;R2 ← Count of how many copies to make
TMK1: MOV (R1)+,(R0)+ ;Transfer first half of floating word
MOV (R1)+,(R0)+ ;Transfer second half of floating word
SOB R2,TMK1 ;Repeat until done
MOV (SP)+,R1 ;R1 ← LOC[arg 2]
MOV #4,R2 ;R2 ← Count of how many copies to make
TMK2: MOV (R1)+,(R0)+ ;Transfer first half of floating word
MOV (R1)+,(R0)+ ;Transfer second half of floating word
SOB R2,TMK2 ;Repeat until done
MOV (SP)+,R2 ;Restore R2
CLR R0 ;Clear condition code.
RTS PC ;Done.
TTMUL:
;Multiplies two transes together. Takes advantage of the fact that
;last row is 0 0 0 1.
MOV R2,-(SP) ;Save R2
MOV (R3)+,R2 ;R2 ← LOC[arg 2]
MOV (R3)+,R1 ;R1 ← LOC[arg 1]
JSR PC,GETTRN ;R0 ← -(R3) ← LOC[new trans]
MOV R3,-(SP) ;Save R3
MOV R4,-(SP) ;Save R4
MOV #4,R4 ;Loop count for cols of answer
MOV R1,-(SP) ;Save a copy of R1
TTM2: LDF (R2)+,AC1 ;Pick up a column of arg2: First row
LDF (R2)+,AC2 ; Second row
LDF (R2)+,AC3 ; Third row
STF AC3,AC4 ; store in AC4
ADD #4,R2 ; Fourth row is zero
MOV #3,R3 ;Loop count for rows of answer
TTM1: LDF (R1),AC3 ;First col of arg 1
MULF AC1,AC3 ;
LDF 20(R1),AC0 ;Second col of arg 1
MULF AC2,AC0 ;
ADDF AC0,AC3 ;
LDF 40(R1),AC0 ;Third col of arg 1
MULF AC4,AC0 ;
ADDF AC0,AC3 ;
STF AC3,(R0)+ ;
ADD #4,R1 ;Move to next column of arg 1
SOB R3,TTM1 ;Repeat for first 3 rows of answer
CLR (R0)+ ;Last row of answer is zero
CLR (R0)+ ;
MOV (SP),R1 ;Reset R1 to point to first row of arg 1
SOB R4,TTM2 ;Repeat for all four columns of answer
LDF -20(R0),AC1 ;Add correction for last column, first row
ADDF 60(R1),AC1 ;
STF AC1,-20(R0) ;
LDF -14(R0),AC1 ;Add correction for last column, second row
ADDF 64(R1),AC1 ;
STF AC1,-14(R0) ;
LDF -10(R0),AC1 ;Add correction for last column, third row
ADDF 70(R1),AC1 ;
STF AC1,-10(R0) ;
MOV ONE,-4(R0) ;Make last col, last row get a one.
TST (SP)+ ;Pop the R1 temp
MOV (SP)+,R4 ;Restore R4
MOV (SP)+,R3 ;Restore R3
MOV (SP)+,R2 ;Restore R2
CLR R0 ;Clear condition code
RTS PC ;Done